home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / src / lib / tclX6.4c / dist / experimental / debugger / ndebug.tcl < prev    next >
Encoding:
Text File  |  1992-03-12  |  3.7 KB  |  148 lines
  1. #@package: experimental_debugger trace_step bp bc tp
  2. #
  3. # ndebug.tcl
  4. #
  5.  
  6. # trace_step is the Tcl procedure called when tracing is done with
  7. # "traceproc"
  8. #
  9. # This is one possible implementation.  We can "step in" and "continue"
  10. # by playing games with the depth, as demonstrated here.
  11. #
  12. # it could do much more, like get and eval input lines, poke into
  13. # variables, and so forth.
  14. #
  15. #
  16. # future
  17. #
  18. # g, print globals
  19. # l, print local vars
  20. #
  21. # have a way to show the argv
  22. # have a way to toggle between command and argv
  23. # 
  24.  
  25. proc trace_step {depth command argv} {
  26.  
  27.     # fix up depth (if condition is true, we were stepping into a procedure
  28.     # and we now need to decrease the depth so we won't step into the
  29.     # next procedure unless commanded to do so
  30.     if {$depth < [tracecon depth]} {
  31.     tracecon depth $depth
  32.     }
  33.  
  34.     echo [replicate "  " [expr {$depth - [tracecon depthfloor]}]]$command
  35.  
  36.     while {1} {
  37.         puts stdout "nsca!? " nonewline
  38.     
  39.         set line [gets stdin]
  40.  
  41.         set command [string index $line 0]
  42.  
  43.         if {$command == "" || $command == "n"} {
  44.         return
  45.         }
  46.  
  47.         if {$command == "s"} {
  48.         tracecon depth [expr {[tracecon depth] + 1}]
  49.         return
  50.         }
  51.  
  52.         if {$command == "c"} {
  53.         tracecon depth [expr {[tracecon depth] - 1}]
  54.         return
  55.         }
  56.  
  57.         if {$command == "!"} {
  58.         if {[string length $line] <= 1} {
  59.             echo "Now in command loop at same level as proc being debugged."
  60.             echo "Enter Control-D to return to the debugger."
  61.             uplevel 1 {commandloop {return "debug> "} {return "debug=> "}}
  62.         } else {
  63.         uplevel 1 [string range $line 1 end]
  64.         }
  65.         continue
  66.         }
  67.  
  68.         if {$command == "a"} {
  69.         echo $argv
  70.         continue
  71.         }
  72.  
  73.  
  74.     if {$command == "?"} {
  75.         echo "a    show the command as it will execute (subordinate expressions evaluated)"
  76.         echo "c    continuous, execute remainder of proc continuously"
  77.         echo "n    next, execute next statement at this depth"
  78.         echo "s    step in, step into next procedure"
  79.         echo "!    push to an interactive command loop"
  80.         echo "!command   execute tcl command"
  81.         continue
  82.     }
  83.     echo "unrecognized command"
  84.     }
  85. }
  86.  
  87. #
  88. # exec_breakpoint
  89. #
  90. # support routine for breakpoints.  We do it by renaming the procedure
  91. # being breakpointed, then create a procedure that calls exec_breakpoint,
  92. # which calls traceproc on the breakpointed procedure.  uplevel magic
  93. # is used to get the variable context from the correct level.
  94. #
  95. proc exec_breakpoint {procedure argv} {
  96.     echo "breakpoint in $procedure"
  97.     uplevel 2 "traceproc ${procedure}_bp $argv"
  98. }
  99.  
  100. #
  101. # bp - breakpoint, turn on breakpoints for one or more named
  102. # procedures, or list procedures with breakpoints defined
  103. # if no procnames are specified
  104. #
  105. proc bp {args} {
  106.  
  107.     foreach procedure $args {
  108.         if {[info procs $procedure] == ""} {
  109.         error "$procedure: no such procedure"
  110.         }
  111.         rename $procedure ${procedure}_bp
  112.  
  113.         proc $procedure {args} "exec_breakpoint $procedure \$args"
  114.     }
  115.  
  116.     if {$args == ""} {
  117.     echo [info procs "*_bp"]
  118.     }
  119. }
  120.  
  121. #
  122. # bc - breakpoint clear, turn off breakpoints for one or more named
  123. # procedures, or all if none are specified
  124. #
  125. #
  126. proc bc {args} {
  127.     if {$args == ""} {
  128.     foreach procedure [info procs "*_bp"] {
  129.         set oldName [string range $procedure 0 [expr {[string length $procedure] - 4}]]
  130.         rename $oldName ""
  131.         rename $procedure $oldName
  132.     }
  133.     echo "all breakpoints cleared"
  134.     return
  135.     }
  136.  
  137.     foreach procedure $args {
  138.         if {[info procs ${procedure}_bp] == ""} continue
  139.         rename $procedure ""
  140.         rename ${procedure}_bp $procedure
  141.     }
  142. }
  143.  
  144. #
  145. # a convenient shorthand for traceproc
  146. #
  147. proc tp {procName} {uplevel "traceproc $procName"}
  148.